home *** CD-ROM | disk | FTP | other *** search
/ The CICA Windows Explosion! / The CICA Windows Explosion! - Disc 2.iso / programr / wtj007.zip / POLYMOR.ZIP / CHARTS.PAS < prev    next >
Pascal/Delphi Source File  |  1992-01-22  |  15KB  |  599 lines
  1. {**************************************************}
  2. {  This unit defines the chart types used in the   }
  3. {  Windows charting program PCHART.PAS.            }
  4. {                  Zack Urlocker                   }
  5. {                    01/22/92                      }
  6. {                                                  }
  7. {  Five types are defined:                         }
  8. {       TChart:       formal type for inheritance  }
  9. {       THBarChart:   horizontal bar chart         }
  10. {       TVBarChart:   vertical bar chart           }
  11. {       TV3DBarChart: vertical 3D bar chart        }
  12. {       TPieChart:    pie chart                    }
  13. {  all types have a common protocol that includes  }
  14. {  drawing, rescaling and stream storage           }
  15. {**************************************************}
  16.  
  17. unit Charts;
  18.  
  19. {$IFDEF Final}        { Remove debug code for final version}
  20. {$D-,I-,L-,R-,S-}
  21. {$ELSE}
  22. {$D+,I+,L+,R+,S+}
  23. {$ENDIF}
  24. interface
  25.  
  26. uses WObjects, Dicts, WinTypes, WinProcs, Strings, StdDlgs, WinDOS;
  27.  
  28. type
  29.  
  30. { Abstract type provides inheritance for other chart types }
  31. PChart = ^TChart;
  32. TChart = object(TObject)
  33. { Object fields }
  34.   Name : PChar;            { title string         }
  35.   Scale : TPoint;          { scaling factor       }
  36.   Area : TPoint;           { size of the chart    }
  37.   Lead : TPoint;           { lead before edges    }
  38.   Space : Integer;         { space between items  }
  39.   Items : PDict;           { key->value pairs     }
  40.  
  41. { Functions and procedures }
  42.   constructor Init;        { so that inheritance works }
  43.   destructor Done; virtual;{ to clean up memory }
  44.   procedure Draw(DC : HDC); virtual;
  45.   procedure DrawTitle(DC : HDC); virtual;
  46.   procedure DrawLabels(DC : HDC); virtual;
  47.   procedure DrawData(DC : HDC); virtual;
  48.   procedure ReScale; virtual;
  49.   procedure AdjustScale(max : Integer); virtual;
  50.   function getItem(x, y : integer) : PAssoc; virtual;
  51.   constructor Load(var S: TStream);
  52.   procedure Store(var S: TStream);
  53.   procedure add(Key : PChar; Value : Integer);
  54.   procedure remove(Key : PChar);
  55.   procedure ResetLead; virtual;
  56.   procedure ResetSpace; virtual;
  57. end;  { Chart }
  58.  
  59. PHBarChart = ^THBarChart;
  60. THBarChart = object(TChart)          { Horizontal bars }
  61.   procedure DrawLabels(DC : HDC); virtual;
  62.   procedure DrawData(DC : HDC); virtual;
  63.   procedure AdjustScale(max : Integer); virtual;
  64.   function getItem(x, y : integer) : PAssoc; virtual;
  65.   procedure ResetLead; virtual;
  66. end;  { THBarChart }
  67.  
  68. PVBarChart = ^TVBarChart;
  69. TVBarChart = object(TChart)          { Vertical bars }
  70.   procedure DrawLabels(DC : HDC); virtual;
  71.   procedure DrawData(DC : HDC); virtual;
  72.   procedure AdjustScale(max : Integer); virtual;
  73.   function getItem(x, y : integer) : PAssoc; virtual;
  74.   procedure ResetSpace; virtual;
  75.   procedure ResetLead; virtual;
  76. end;  { TVBarChart }
  77.  
  78. PV3DBarChart = ^TV3DBarChart;        { Vertical 3D bars }
  79. TV3DBarChart = object(TVBarChart)
  80.   procedure DrawData(DC : HDC); virtual;
  81. end;  { V3DBarChart }
  82.  
  83. PPieChart = ^TPieChart;
  84. TPieChart = object(TChart)           { Pie charts }
  85.   procedure DrawLabels(DC : HDC); virtual;
  86.   procedure DrawData(DC : HDC); virtual;
  87.   procedure AdjustScale(max : Integer); virtual;
  88.   function getItem(x, y : integer) : PAssoc; virtual;
  89.   procedure ResetSpace; virtual;
  90. end;  { TPieChart }
  91.  
  92.  
  93. implementation
  94.  
  95. const
  96.   Black = $000000;       { Windows color constants }
  97.   White = $FFFFFF;
  98.   Blue  = $FF0000;
  99.   Green = $00FF00;
  100.   Red   = $0000FF;
  101.  
  102.  
  103. { *********   Chart  ********* }
  104.  
  105. constructor TChart.Init;
  106. begin
  107.   GetMem(Name, 255);
  108.   Scale.x := 0;
  109.   Scale.y := 0;
  110.   Area.x := 0;
  111.   Area.y := 0;
  112.   ResetLead;
  113.   ResetSpace;
  114.   new(Items, init(10,5));
  115. end;
  116.  
  117. { Dispose of the chart by deallocating memory. }
  118. destructor TChart.Done;
  119. begin
  120.   StrDispose(Name);
  121.   Items^.Done;
  122. end;
  123.  
  124. { Draw a chart in the area }
  125. procedure TChart.Draw(DC : HDC);
  126. var s : array[0..16] of char;
  127. begin
  128.   if Name <> nil then
  129.     DrawTitle(DC);
  130.   if items^.size > 0 then
  131.   begin
  132.     DrawLabels(DC);
  133.     DrawData(DC);
  134.   end
  135.   else
  136.   begin
  137.     strPCopy(S, '(Empty chart)');
  138.     TextOut(DC, 1, 2, s, strLen(s));
  139.   end;
  140. end;
  141.  
  142. { Draw the title, centered in a custom font}
  143. procedure TChart.DrawTitle(DC : HDC);
  144. var FontInfo: TLogFont;
  145.     oldFont, newFont : HFont;
  146.     x : Integer;
  147. begin
  148.   { set the font }
  149.   with FontInfo do
  150.   begin
  151.     lfHeight := 30;
  152.     lfWidth := 0;
  153.    lfEscapement:= 0;
  154.    lfOrientation:= 0;
  155.     lfWeight := 700;
  156.     lfItalic := 0;
  157.     lfUnderLine := 0;
  158.     lfStrikeOut := 0;
  159.    lfCharSet:= ANSI_CharSet;
  160.    lfOutPrecision:= Out_Default_Precis;
  161.    lfClipPrecision:= clip_Default_Precis;
  162.     lfQuality := Proof_Quality;
  163.    lfPitchAndFamily:= default_Pitch + ff_Roman;
  164.     strPcopy(lfFaceName, 'Tms Rmn');
  165.   end;
  166.  
  167.   newFont := createFontIndirect(FontInfo);
  168.   OldFont := SelectObject(DC, newFont);
  169.  
  170.   x := area.x div 2 - strLen(Name) * 10;
  171.   TextOut(DC, x, 1, Name, strLen(Name));
  172.  
  173.   { Reset the font when done }
  174.   selectObject(DC, oldFont);
  175.   DeleteObject(newFont);
  176. end;
  177.  
  178. { Force the chart to adjust its scale }
  179. procedure TChart.ReScale;
  180. var Max : Integer;
  181. begin
  182.   Max := Items^.MaxValue;
  183.   If Max > 0 then
  184.   begin
  185.     resetLead;
  186.     resetSpace;
  187.     adjustScale(Max);
  188.   end;
  189. end;
  190.  
  191. { Abstract methods that must be implemented in descendant classes. }
  192. procedure TChart.DrawData(DC : HDC);
  193. begin
  194.   abstract;
  195. end;
  196.  
  197. procedure TChart.DrawLabels(DC : HDC);
  198. begin
  199.   abstract;
  200. end;
  201.  
  202. procedure TChart.AdjustScale(max:Integer);
  203. begin
  204.   abstract;
  205. end;
  206.  
  207. function TChart.getItem(x, y : integer) : PAssoc;
  208. begin
  209.   abstract;
  210. end;
  211.  
  212.  
  213. { File and stream I/O methods }
  214.  
  215. constructor TChart.Load(var S:TStream);
  216. { Load a chart from a stream. Must be read in same order written. }
  217. begin
  218.   Name := S.StrRead;
  219.   Items := PDict(S.Get);
  220. end;
  221.  
  222. procedure TChart.Store(var S:TStream);
  223. { Store a chart onto a stream. Not all object fields are stored.
  224.   For example, scale, area, lead, space are set properly when
  225.   you rescale. Must be read in the exact same order. }
  226. begin
  227.   S.StrWrite(Name);
  228.   S.Put(Items);
  229. end;
  230.  
  231. { Miscelaneous access methods }
  232.  
  233. procedure TChart.add(Key : PChar; Value : Integer);
  234. begin
  235.   Items^.update(Key, Value);
  236. end;
  237.  
  238. procedure TChart.remove(Key : PChar);
  239. begin
  240.   Items^.remove(Key);
  241. end;
  242.  
  243. procedure TChart.ResetLead;
  244. begin
  245.   Lead.x := 10;
  246.   Lead.y := 30;
  247. end;
  248.  
  249. procedure TChart.ResetSpace;
  250. begin
  251.   Space := 10;
  252. end;
  253.  
  254.  
  255. { *********   THBarChart  ********* }
  256.  
  257. { Draw labels with a stock font }
  258. procedure THBarChart.DrawLabels(DC : HDC);
  259. var I, x, y : Integer;
  260.     str : PChar;
  261.  
  262.   procedure DrawLabel(Item : PAssoc); far;
  263.   begin
  264.     y := Lead.y + i*(Scale.y + space);
  265.     str := Item^.key;
  266.     TextOut(DC, x, y, str, strLen(str));
  267.     inc(i);
  268.   end;
  269.  
  270. begin
  271.   x := 1;
  272.   i := 0;
  273.   selectObject(DC, getStockObject(ansi_fixed_font));
  274.   Items^.ForEach(@DrawLabel);
  275.   selectObject(DC, getStockObject(system_font));
  276. end;
  277.  
  278. { Draw the bars in the chart }
  279. procedure THBarChart.DrawData(DC : HDC);
  280. var I, x, y : Integer;
  281.  
  282.   procedure DrawItem(Item : PAssoc); far;
  283.   begin
  284.     y := Lead.y + i*(Scale.y + space);
  285.     Rectangle(DC, x, y, round(x+Item^.value*scale.x), y+scale.y);
  286.     inc(i);
  287.   end;
  288.  
  289. begin
  290.   x := lead.x;
  291.   i := 0;
  292.   SelectObject(DC, CreateSolidBrush(Blue));
  293.   Items^.ForEach(@DrawItem);
  294.   DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
  295. end;
  296.  
  297. { Adjust the scale horizontally }
  298. procedure THBarChart.AdjustScale(max : Integer);
  299. begin
  300.   scale.x := (area.x - 2 * lead.x) div max;
  301.   scale.y := 25;
  302. end;
  303.  
  304. { Return item found at location x, y }
  305. function THBarChart.getItem(x, y : integer) : PAssoc;
  306. var index : Integer;
  307. begin
  308.  index := trunc((y - lead.y)/ (scale.y + space));
  309.  if index < Items^.size then
  310.    getItem := Items^.at(index)
  311.  else
  312.    getItem := nil;
  313. end;
  314.  
  315. { Reset the lead for this type of chart }
  316. procedure THBarChart.resetLead;
  317. begin
  318.   lead.x := 60;
  319.   lead.y := 30;
  320. end;
  321.  
  322.  
  323. { *********   TVBarChart  ********* }
  324.  
  325. { Draw labels in color font }
  326. procedure TVBarChart.DrawLabels(DC : HDC);
  327. var I, x, y : Integer;
  328.     str : PChar;
  329.  
  330.   procedure DrawLabel(Item : PAssoc); far;
  331.   begin
  332.     x := i*(Scale.x+space) + lead.x;
  333.     str := Item^.key;
  334.     TextOut(DC, x, y, str, strLen(str));
  335.     inc(i);
  336.   end;
  337.  
  338. begin
  339.   i := 0;
  340.   y := area.y - lead.y+1;
  341.   setTextColor(DC, Blue);
  342.   Items^.ForEach(@DrawLabel);
  343.   setTextColor(DC, Black);
  344. end;
  345.  
  346. { Draw the bars in the chart }
  347. procedure TVBarChart.DrawData(DC : HDC);
  348. var I, x, y : Integer;
  349.  
  350.   procedure DrawItem(Item : PAssoc); far;
  351.   begin
  352.     x := Lead.x + i*(Scale.x + space);
  353.     Rectangle(DC, x+Scale.x, area.y - lead.y, x,
  354.      round(area.y-lead.y-Item^.value*scale.y));
  355.     inc(i);
  356.   end;
  357.  
  358. begin
  359.   i := 0;
  360.   SelectObject(DC, CreateSolidBrush(Red));
  361.   Items^.ForEach(@DrawItem);
  362.   DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
  363. end;
  364.  
  365. { Adjust the scale vertically }
  366. procedure TVBarChart.AdjustScale(max : Integer);
  367. begin
  368.   scale.x := 30;
  369.   scale.y := (area.y - 2 * lead.y) div max;
  370. end;
  371.  
  372. { Return item found at location x, y }
  373. function TVBarChart.getItem(x, y : integer) : PAssoc;
  374. var index : Integer;
  375. begin
  376.  index := trunc((x - lead.x)/ (scale.x + space));
  377.   if index < items^.size then
  378.    getItem := Items^.at(index)
  379.  else
  380.    getItem := nil;
  381. end;
  382.  
  383. { Reset the lead for this type of chart }
  384. procedure TVBarChart.resetLead;
  385. begin
  386.   lead.x := 10;
  387.   lead.y := 30;
  388. end;
  389.  
  390. { Reset the space for this type of chart }
  391. procedure TVBarChart.ResetSpace;
  392. begin
  393.   Space := 30;
  394. end;
  395.  
  396.  
  397. { *********   V3DBarChart *********}
  398.  
  399. { Draw each 3D bar as a vertical bar, side and top polygons }
  400. procedure TV3DBarChart.DrawData(DC : HDC);
  401. var I, x, y : Integer;
  402.  
  403.   procedure DrawItem(Item : PAssoc); far;
  404.   var points : array[1..4] of TPoint;
  405.   begin
  406.     x := Lead.x + i*(Scale.x + space);
  407.     y := area.y-lead.y-Item^.value*scale.y;
  408.     { regular vertical bar }
  409.      Rectangle(DC, x+Scale.x, area.y - lead.y, x, y);
  410.     { right side }
  411.     points[1].x := x+Scale.x - 1 ;
  412.     points[1].y := area.y - lead.y - 1;
  413.     points[2].x := x+Scale.x + space div 2 - 1;
  414.     points[2].y := area.y - lead.y - space div 2 - 1;
  415.     points[3].x := points[2].x;
  416.     points[3].y := y - space div 2;
  417.     points[4].x := x+Scale.x - 1;
  418.     points[4].y := y;
  419.     Polygon(DC, points, 4);
  420.     { top }
  421.     points[1].x := x;
  422.     points[1].y := points[4].y;
  423.     points[2].x := x + space div 2;
  424.     points[2].y := points[3].y;
  425.     Polygon(DC, points, 4);
  426.     inc(i);
  427.   end;
  428.  
  429. begin
  430.   i := 0;
  431.   SelectObject(DC, CreateSolidBrush(Green));
  432.   Items^.ForEach(@DrawItem);
  433.   DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
  434. end;
  435.  
  436.  
  437. { *********   TPieChart  ********* }
  438.  
  439. const
  440.   { This table is used to cycle through RGB values of 0,
  441.     128, 255 for each color.  This provides 27 patterns,
  442.     of which normally any consecutive 10 are unique. }
  443.     colors : array[0..2] of byte = (0, 128, 255);
  444.  
  445. { Draw the labels and legends using a custom logical font }
  446. procedure TPieChart.DrawLabels(DC : HDC);
  447. var I, x, y : Integer;
  448.     s : PChar;
  449.     newFont, oldFont : hFont;
  450.     FontInfo : TLogFont;
  451.  
  452.   procedure DrawLabel(Item : PAssoc); far;
  453.   var color : Longint;
  454.   begin
  455.     y := lead.y + i * space;
  456.     s := Item^.key;
  457.     TextOut(DC, x, y, s, strLen(s));
  458.  
  459.     color := RGB(colors[I mod 3],
  460.                  colors[(I div 3) mod 3],
  461.                  colors[(I div 9) mod 3]);
  462.     SelectObject(DC, CreateSolidBrush(color));
  463.     Rectangle(DC, x + 60, y, x + 90, y + space div 2);
  464.     DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
  465.     inc(i);
  466.   end;
  467.  
  468. begin
  469.   { Create a logical font and select it }
  470.   with FontInfo do
  471.   begin
  472.     lfHeight := 18;
  473.     lfWidth := 0;
  474.     lfWeight := 700;
  475.     lfUnderLine := 0;
  476.     lfStrikeOut := 0;
  477.     lfItalic := 0;
  478.     strPcopy(lfFaceName, 'Tms Rmn');
  479.   end;
  480.   newFont := createFontIndirect(FontInfo);
  481.   OldFont := SelectObject(DC, newFont);
  482.   x := scale.x + space;
  483.   i := 0;
  484.   Items^.ForEach(@DrawLabel);
  485.   { Reset the font when done }
  486.   selectObject(DC, oldFont);
  487.   DeleteObject(newFont);
  488. end;
  489.  
  490. const TWO_PI = Pi * 2.0;
  491.  
  492. { Draw the wedges in the pie }
  493. procedure TPieChart.DrawData(DC : HDC);
  494. var i, x, y, total : Integer;
  495.     nsum : array [0..26] of Integer;
  496.  
  497.   { Accumulate running total for Pies }
  498.   procedure addItems(Item : PAssoc); far;
  499.   begin
  500.     nsum[i+1] := nsum[i] + Item^.Value;
  501.     inc(i);
  502.   end;
  503.  
  504.   procedure DrawItem(Item : PAssoc); far;
  505.   var color : LongInt;
  506.   begin
  507.     color := RGB(colors[I mod 3],
  508.                  colors[(I div 3) mod 3],
  509.                  colors[(I div 9) mod 3]);
  510.     SelectObject(DC, CreateSolidBrush(color));
  511.     Pie(DC, lead.x, lead.y,
  512.       scale.x+lead.x, scale.y+lead.y,
  513.       round(((x*cos(TWO_PI*nSum[i+1]/total)))+x)+lead.x,
  514.       round(((y*sin(TWO_PI*nSum[i+1]/total)))+y)+lead.y,
  515.       round(((x*cos(TWO_PI*nSum[i]/total)))+x)+lead.x,
  516.       round(((y*sin(TWO_PI*nSum[i]/total)))+y)+lead.y);
  517.     DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
  518.     inc(i);
  519.   end;
  520.  
  521. begin
  522.   nsum[0] := 0;
  523.   i := 0;
  524.   Items^.ForEach(@AddItems);
  525.   total := nsum[items^.size];
  526.   x := scale.x div 2;
  527.   y := scale.y div 2;
  528.   i := 0;
  529.   Items^.ForEach(@DrawItem);
  530. end;
  531.  
  532. { Adjust the scale horizontally }
  533. procedure TPieChart.AdjustScale(max : Integer);
  534. begin
  535.   scale.x := round(0.95 *(area.y - lead.y));
  536.   scale.y := scale.x;
  537. end;
  538.  
  539. { Return item found at legend location x, y }
  540. function TPieChart.getItem(x, y : integer) : PAssoc;
  541. var index : Integer;
  542. begin
  543.  index := trunc((y - lead.y)/ (space));
  544.  if (index < items^.size) and (x >= scale.x + space) then
  545.    getItem := Items^.at(index)
  546.  else
  547.    getItem := nil;
  548. end;
  549.  
  550. { Adjust the space for this type of chart }
  551. procedure TPieChart.resetSpace;
  552. begin
  553.   space := area.y div 7;
  554. end;
  555.  
  556.  
  557. { Stream Registration records for each chart type }
  558.  
  559. const
  560.   RChart: TStreamRec = (
  561.     ObjType: 1002;
  562.     VmtLink: Ofs(TypeOf(TChart)^);
  563.     Load: @TChart.load;
  564.     Store: @TChart.store);
  565.  
  566.   RHBarChart: TStreamRec = (
  567.     ObjType: 1003;
  568.     VmtLink: Ofs(TypeOf(THBarChart)^);
  569.     Load: @THBarChart.load;
  570.     Store: @THBarChart.store);
  571.  
  572.   RVBarChart: TStreamRec = (
  573.     ObjType: 1004;
  574.     VmtLink: Ofs(TypeOf(TVBarChart)^);
  575.     Load: @TVBarChart.load;
  576.     Store: @TVBarChart.store);
  577.  
  578.   RV3DBarChart: TStreamRec = (
  579.     ObjType: 1005;
  580.     VmtLink: Ofs(TypeOf(TV3DBarChart)^);
  581.     Load: @TV3DBarChart.load;
  582.     Store: @TV3DBarChart.store);
  583.  
  584.   RPieChart: TStreamRec = (
  585.     ObjType: 1006;
  586.     VmtLink: Ofs(TypeOf(TPieChart)^);
  587.     Load: @TPieChart.load;
  588.     Store: @TPieChart.store);
  589.  
  590.  
  591. { Initialization }
  592. begin
  593.   RegisterType(RChart);
  594.   RegisterType(RHBarChart);
  595.   RegisterType(RVBarChart);
  596.   RegisterType(RV3DBarChart);
  597.   RegisterType(RPieChart);
  598. end.
  599.